home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / Module source / Util < prev    next >
Text File  |  1994-06-24  |  6KB  |  248 lines
  1. \ Utility words for Yerk
  2. \ 10/13/84  CBD Combined with Dump.scr
  3. \ 12/16/84  CBD Made into a module
  4. \  1/04/85  cdn Moved in objList
  5. \  7/10/86  cdn Moved in .classes
  6. \  9/02/86  cdn Added Option & Shift key features to WORDS
  7. \  9/04/86  ghs Added pat
  8. \ 12/04/87  rfl modified .cline to use better format and increased clist size
  9. \ 12/04/87    rfl fixed dump format
  10. \ 10/02/90    rfl    .pause now in nucleus
  11. \ 10/26/91    rfl    added class hierarchy
  12. \ 12/14/91    rfl    modified .class to not be reentrant..runs out of stack
  13. \ 12/17/91    rfl    improved hier...someday will have browser
  14. \ 10/16/92    rfl    added listing of objects in .clist
  15. \ 11/10/93    rfl    added pause in objlist
  16. \  1/18/94    rfl    removed ?pause from words, so that module will unlock if aborted
  17.  
  18. Decimal
  19.  
  20. :Module Util
  21.  
  22. : Dump
  23.     base >R HEX CR CR
  24.     ." Dump from address: " over . CR 7 SPACES
  25.     16 0 DO I 3 .R LOOP 2 SPACES
  26.         16 0 DO I 0 <# # #> TYPE LOOP CR
  27.         OVER + SWAP DUP 15 AND XOR
  28.         DO    CR i 0 6 D.R SPACE
  29.             i 16 + i 2DUP
  30.             DO  ic@ SPACE 0 <# # # #> TYPE LOOP
  31.             2 SPACES
  32.             DO  ic@ DUP 32 < OVER 126 > OR
  33.                 IF DROP 46   THEN
  34.                 EMIT
  35.             LOOP
  36.         ?pause
  37.         16 +LOOP
  38.     CR R> -> BASE ;
  39.  
  40. \ pull name from stream and dump from its NFA
  41. : .W    @Pfa  nfa 100 Dump  ;
  42.  
  43. \ List words in dictionary
  44. : Words { \ eop wbase -- }
  45.     latest true
  46.     mods: fEvent 2048 and    \ option key is down- prompt for word name
  47.     IF    2drop " List from name:" doInDlg dup
  48.         IF    drop sFind 0= Abort" not found"
  49.             drop nfa true
  50.         THEN
  51.     THEN
  52.     mods: fEvent  512 and    \ shift key is down- prompt for address
  53.     IF    2drop " List from hex address:" doInDlg dup
  54.         IF    drop here >str255 1+ here c@ >uc
  55.             BL here count + c!        \ make usable by "number"
  56.             base -> wbase hex
  57.             here number drop 0 max latest
  58.             BEGIN 2dup pfa lfa @ <    \ find the nearest word
  59.             WHILE pfa lfa @
  60.             REPEAT swap drop true
  61.             wbase -> base
  62.         THEN
  63.     THEN
  64.     0= IF exit THEN    \ Cancel button from a dialog box
  65.     getvrect: fWind drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop
  66.     Base -> wbase HEX  Cr Cr 0 -> out
  67.     BEGIN
  68.         dup dup 6 .R
  69.         dup  1+ C@
  70.         IF  space ID.
  71.         ELSE  ."  Null" drop
  72.         THEN out eop >
  73.         IF  Cr 0 -> Out
  74.         ELSE  20 out over mod - spaces
  75.         THEN  pfa lfa @ dup 0=
  76.         ?terminal                        \ don't use ?pause, because abort won't
  77.                                         \ unlock module
  78.           IF (key) drop cr .pause (key)
  79.              cr 0 -> out 32 > IF drop true THEN
  80.           THEN
  81.     UNTIL
  82.     drop Cr wbase -> Base ;
  83.  
  84. \ trav handler for finding objects of a class
  85. : ofind { theCfa theClass -- }
  86.     theCfa @ theClass =
  87.     IF cr theCfa >name dup id.  .h ?pause THEN   ;
  88.  
  89. : objList {  addr len \ theClass -- } addr len sFind
  90.     0= ?error 122
  91.     drop  ?isClass 0= ?error 122   -> theClass
  92.     cr ." Objects of class: " addr len type
  93.     'c ofind theClass trav  cr ;
  94.  
  95. 0 value cList
  96. 0 value level
  97. 0 value #obs
  98.  
  99. hex    \ changes text in place
  100. Create >lc    ( addr len -- addr len )
  101.     2e17    w,    \         move.l    (sp),d7
  102.     206f0004 ,    \         move.l    4(sp),a0
  103.     d1cb    w,    \         adda.l    a3,a0
  104.     5387    w,    \         subq    #1,d7
  105.     1018    w,    \ lp    move.b    (a0)+,d0
  106.     0c000041 ,    \         cmpi.b    #65,d0
  107.     6b0e    w,    \         bmi.s    out
  108.     0c00005a ,    \         cmpi.b    #90,d0
  109.     6e08    w,    \         bgt.s    out
  110.     d03c0020 ,    \         add.b    #32,d0
  111.     1140ffff ,    \         move.b    d0,-1(a0)
  112.     51cfffe8 ,    \ out    dbra    d7,lp
  113. next,
  114. decimal
  115.  
  116. \ trav handler for finding objects of a class
  117. : obfind { theCfa theClass \ len -- }
  118.     theCfa @ theClass =
  119.      IF cr level 1+ 2* spaces theCfa >name dup .h 2 spaces n>count -> len
  120.         here len cmove here len >lc type     \ move name to here
  121.         1 ++> #obs
  122.      THEN  ;
  123.  
  124. ' meta constant lastCl
  125.  
  126. \  Handler to add all classes to cList during a Trav
  127. : addClass { theCfa parm -- }
  128.     theCfa  lastCl >
  129.     IF  theCfa 4+ ?IsClass
  130.         IF  add: cList
  131.         ELSE drop
  132.         THEN
  133.     THEN ;
  134.  
  135. : fillClist   clear: clist 0 add: clist 'c addClass 0 trav   ;
  136.  
  137. \ ( ind -- ^super )
  138. : superOF  at: cList  sfa @  ;
  139.  
  140. \ find the next subclass for the given superclass ptr
  141. : nextSub { ^sup start \ bool -- subInd t OR f }
  142.     0 -> bool
  143.     size: cList  start
  144.     DO  i superOF  ^sup =
  145.         IF  i true -> bool  Leave
  146.         THEN
  147.     LOOP bool ;
  148.  
  149. : tab 6 * @xy drop - 6 / spaces ;
  150.  
  151. \ print a line of data for this class
  152. : .cline ( ind -- )
  153.     cr level 2* spaces
  154.     at: cList  dup dup nfa 4 tface id. 0 tface
  155.     dup dfa w@ 35 tab ." Dlen:" .  dfa 2+ w@ 46 tab ." Width:" . 
  156.     'c obfind swap trav  ;
  157.  
  158. \ patch .cline .cline1
  159.  
  160. \ ( ind -- ind subInd t OR ind f )  try to nest into subclass
  161. : ?sub  dup at: clist 0 nextSub  ;
  162.  
  163. \ ( ind -- newInd t or f )  try to find a peer class
  164. : ?peer
  165.     dup superOF lastCL =
  166.     IF false  THEN
  167.     dup superOF  swap 1+ nextSub  ;
  168.  
  169. : findPeer { ind  -- ind }
  170.     BEGIN ind ?peer                        \ does it have a peer class?
  171.           IF -> ind true                 \ yes, so get out
  172.           ELSE -1 ++> level    level 0=    \ no, so pop up and do again
  173.                 IF 0 -> ind true
  174.                 ELSE -> ind false
  175.                 THEN
  176.           THEN
  177.     UNTIL ind  ;
  178.  
  179. : classTrav { ind -- }
  180.     BEGIN ?terminal
  181.           IF (key) drop cr .pause (key)
  182.              cr 0 -> out 32 > IF exit THEN
  183.           THEN
  184.           ind .cline
  185.           ind ?sub                            \ does it have a subclass?
  186.           IF   1 ++> level -> ind            \ yes, so dip down and save last class index
  187.           ELSE findPeer    -> ind                \ otherwise find next peer
  188.           THEN
  189.           ind not
  190.     UNTIL ;
  191.  
  192. : .cl  size: clist 0 DO i at: clist cr nfa id. LOOP  ;
  193.  
  194. : .classes 0 -> level 0 -> #obs
  195.     400 heap> Ordered-Col -> cList
  196.     fillClist  size: clist 1-  classTrav level 0 do drop loop cr cr
  197.     size: clist ." number of classes is " . cr 
  198.     #obs ." number of objects is " . cr
  199.     dispose> cList ;
  200.  
  201. rect pbox
  202.  
  203. \ Display the system pen patterns
  204. : pat { \ pattern -- }
  205.     0 -> pattern -curs cls
  206.     1 8 50 38 put: pbox 6 0
  207.     DO    7 0
  208.         DO    pattern 38 = IF 3 sysPat +base call PenPat THEN
  209.             55 0 offset: pbox  pattern sysPat fill: pbox  draw: pbox
  210.             getBotX: pbox 38 -  getBotY: pbox 9 +  gotoxy  pattern .
  211.             1 ++> pattern
  212.         LOOP
  213.         -385 40 offset: pbox
  214.     LOOP
  215.     0 sysPat +base call PenPat
  216.     CR +curs
  217. ;
  218.  
  219.  
  220. \ ************
  221. \ : (chain) { myobj \ tab -- } cr 0 -> tab
  222. \         BEGIN  2 ++> tab myObj sfa @ -> myObj
  223. \                myObj nfa n>count 2dup tab spaces type cr " OBJECT" s=
  224. \         UNTIL ;
  225.  
  226. : (chain) { myObj \ tab -- } 40 heap> ordered-col -> clist
  227.         cr 0 -> tab myObj add: clist
  228.         BEGIN    myObj sfa @ -> myObj
  229.                 myObj add: clist
  230.                 myObj nfa n>count  " OBJECT" s=
  231.         UNTIL 
  232.         size: clist 0
  233.         DO  2 ++> tab last: clist nfa n>count tab spaces type cr
  234.             size: clist 1- remove: clist
  235.         LOOP dispose> clist ;
  236.  
  237. : hc'
  238.     @word count sfind
  239.     IF drop (chain) THEN ;
  240.  
  241. : hier  " List class hierarchy of class:" doInDlg
  242.         IF  sFind 0= Abort" not found"
  243.             drop ?isclass IF (chain) ELSE abort" not a class" THEN
  244.         THEN ;
  245.  
  246.  
  247. ;Module
  248.